perm filename PGSUB.F4[PAG,LCS]9 blob sn#513521 filedate 1980-06-03 generic text, type T, neo UTF8
C****  VARIOUS SUBROUTINES FOR PAGE LAYOUT PROGRAM. ****

	SUBROUTINE FILOUT(NAMQ,NPG)
	COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
	1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2
	1  /SF/KL,RT,KP,STFSZ,NAMX,EXT /IVV/NUMS(1)
2	FORMAT(' TYPE FILE NAME  '$)
102	FORMAT(A5)
103	TYPE 2
	CALL READX(5,NAMX,EXT,NPG,NUMS)
CC103	CALL NAMEXT(EXT)
	IF(NAMX.NE.' ')GO TO 1
	EXT='TST'
	NAMX='AAAAA'
1	NAMZ=NAMX
	NPG=1
	IF(LOOKX(NAMX,EXT).GE.0)RETURN
CC	IF(LOOKX(NAMX,EXT).GE.0)GO TO 88
	TYPE 88,NAMX,EXT
	ACCEPT 102,L
	IF(L.EQ.'N')GO TO 103
88	FORMAT(' WRITE OVER FILE ',A5,'.',A3,'????  '$)
	END

	SUBROUTINE FILEIN
	COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
	1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /IPG/IPG,JPG,
	1 BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) 
	1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
	COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
	COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
	COMMON/STF/RSTFAC(0/7),RSTJ2 /PX/KPN(1) /Q/Q(1)
	1 /NBAR/NBAR(1)
	EQUIVALENCE (LASTNM,KBAR(3))

CCC	IF(NMPG.EQ.'PAGEA')NPZ='PAGEZ'
	IF(NBAR(LC).EQ.0)CALL EXIT
	IF(KPX.EQ.1)GO TO 104
C  SKIP THIS FIRST TIME.  IT SHUFFLES DATA FORWARD IN ARRAY.
	J=KPX-1
	JJ=KPN(KPX)-1
	DO 105 K=1,NPX-J
105	KPN(K)=KPN(K+J)-JJ
	J=KPN(NPX)-JJ
C  HOW MUCH TO SHIFT THE Q ARRAY
CX	DO 106 K=1,J
CX106	Q(K)=Q(K+JJ)
	CALL RLOOP(Q,Q(JJ+1),J)
	KPX =NPX-KPX+1
C  UPDATE POINTERS FOR NEXT READIN
	KQ=KPN(KPX)
	JPX=KQ-1

104	KL=1
	KP=1
	JEND=0
C  FLAG FOR PAGE END - WHEN -1
	IF(LB.LT.NBAR(LC))GO TO 220
	NPX=KPX
	KPX=1
	LB=0
	GO TO 241
C*** 220	CALL GETEXT(NMPG,'PAG')
C*** 	CALL EXTIN(RSTFAC,22)
C*** 211	CALL EXTIN(KPN(KPX),JJ2)
C*** 	CALL EXTIN(Q(KQ),JPQ)
C NEW SAVE FORMAT.  NEXT DOES ALL THE ABOVE.
220	CALL INMUS(NMPG,'PAG',Q(KQ),KPN(KPX),RSTFAC)
	JP=JJ2+KPX
	IF(JP.LE.450)GO TO 1211
	TYPE 3211,JP
	STOP
3211	FORMAT(' ARRAY OVERLOAD. KPN=',I3,'/450')
4211	FORMAT(' ARRAY OVERLOAD. Q=',I4,'/4500')
1211	JP=KQ+JPQ
	IF(JP.LE.4500)GO TO 2211
	TYPE 4211,JP
	STOP
2211	IF(KPX.EQ.1)GO TO 140
CC	IF(KPX.EQ.LPX)GO TO 311
C  AVOIDS DOUBLE METERS, I HOPE!
CC	IF(Q(KQ+1).NE.18)GO TO 311
C LOOK AT FIRST NEW ITEM, IS IT A METER?
CC	KPX=LPX
CC	KQ=KPN(KPX)
C YES, GO BACK AND READ OVER OLD METERS.
CC	JPX=KQ-1
CC	GO TO 220
311	OLD=Q(KPN(KPX-1)+3)
	B=0
	JJ=JJ2+KPX-2
CC*******3/27/80 CHANGED TO -2	JJ=JJ2+KPX-1
	DO 420 JP=KPX,JJ
	K=KPN(JP)+JPX
	KPN(JP)=K
	R=Q(K+1)
	IF(B.NE.0)GO TO 420
	IF(R.LE.2)GO TO 620
	IF(R.NE.18)GO TO 420
CHECK UP ON METER DUPLICATE.
	DO 720 KK=KPX-1,1,-1
	R=CODEN(KPN,KK,Q,LA)
720	IF(R.NE.18)GO TO 820
	GO TO 420
820	IF(KK.EQ.KPX-1)GO TO 420
	KPX=KK+1
	KQ=KPN(KPX)
	JPX=KQ-1
C GO BACK AND READ OVER DANGLING METER
	GO TO 220
620	B=Q(K+3)
C B=POS OF FIRST NOTE OR REST IN NEW FILE.
	DO 1 KK=KPX,JP
	R=CODEN(KPN,KK,Q,LA)
	IF(R.NE.44)GO TO 7
	IF(Q(LA+6).EQ.0.OR.Q(LA).LT.4)GO TO 1
C LOOK AT LINES, CRESC, DASHES, WIGGLES ONLY.
	GO TO 2
7	IF(R.NE.7)GO TO 5
	IF(Q(LA).LT.5)GO TO 1
	RR=ABS(Q(LA+7))
	IF(RR.GT.1.AND.RR.LT.8)GO TO 1
C AVOID PEDAL MARKS.
	GO TO 2
5	IF(R.NE.5)GO TO 1
C FOUND SLUR INTO LEFT SIDE OF LINE
	IF(Q(LA+3))Q(LA+3)=B-5
	A=Q(LA+6)
	C=Q(LA+2)
2	DO 3 NN=1,KPX-1
	RR=CODEN(KPN,NN,Q,II)
	IF(RR.NE.R)GO TO 3
	IF(Q(II).LT.4)GO TO 3
	IF(Q(II+3).GT.D)GO TO 3
	IF(Q(II+2).NE.C)GO TO 3
C CATCHES ONLY ONE SLUR(ETC.) POS PER STAFF!!
	IF(Q(II+6).LT.D)GO TO 3
	Q(II+6)=A
C  ADJUSTS PARAM 6 TO POSITION IN NEW FILE.
	GO TO 1
3	CONTINUE
1	CONTINUE
420	CONTINUE
140	JPX=KQ+JPQ-3
C  NUM OF WORDS TO SHIFT.
	LPX=KPX
C  SO IT WON'T GET CONFUSED
41	NMPG=NMPG+2
C  NMPG = NAME OF INPUT FILES
	IF(NMPG.EQ.'PAGEZ'+2)NMPG='PAGFA'
C  WILL GO FROM PAGEA TO PAGFZ, ETC. (104)  ADD TO THIS IF NEEDED.
	IF(NMPG.EQ.'PAGFZ'+2)NMPG='PAGGA'
	IF(NMPG.EQ.'PAGGZ'+2)NMPG='PAGHA'
CCC	IF(NMPG.LE.NPZ)GO TO 2242
CCC	NPZ=NPZ+256
CCC	NMPG='PAGFA'
CC	L=JJ2-2
CC	NPX=KPX+L
2242	NPX=KPX+JJ2-2
241	JBAR=NBAR(LC)

	DO 20 JP=KPX,NPX-1
	R=CODEN(KPN,JP,Q,N)
CC	N=KPN(JP)   	R=Q(N+1)
	IF(R.NE.4)GO TO 20
C  FINDS BAR LINES IN THIS PART OF DATA
	LB=LB+1
	IF(LB.NE.JBAR)GO TO 20
	KPX=JP+1
	D=Q(N+3)
		DO 121 L=JP-1,1,-1
		R=CODEN(KPN,L,Q,N)
		IF(R.NE.5)GO TO 121
		RR=Q(N+6)
		IF(RR.LT.D)GO TO 121
		Q(N+6)=-1
		C=Q(N+2)
		B=0
			DO 221 KK=JP+1,NPX-1
			R=CODEN(KPN,KK,Q,NN)
			IF(R.NE.1)GO TO 221
			IF(Q(NN+2).NE.C)GO TO 221
C		  CHECK ON STAFF NUM.
			A=Q(NN+3)-1
			IF(RR.LT.A)GO TO 221
			B=B-1
			IF(ABS(RR-A).LE.2)GO TO 321
C		IF IT'S CLOSE ENOUGH CALL IT EQUAL.
221			CONTINUE
321		IF(B)Q(N+6)=B
121		CONTINUE
C  SAVE POS OF LAST BAR FOR SLUR CONNECTIONS, ETC.
CC	LPX=KPX
C  SAVE POINTER IN CASE OF DOUBLE METERS.
20	CONTINUE
	IF(LB.GE.JBAR)GO TO 520
	KPX=NPX
	KQ=JPX+1
	GO TO 220
520	KQ=Q(KPN(KPX)+1)
	IF(KQ.NE.18.AND.KQ.NE.44.AND.KQ.NE.3.AND.KQ.NE.17)GO TO 120
C LOOKS FOR KEY SIG, CLEF, METER OR SECONDARY BAR LINE(44) BEYOND LAST BAR IN LINE
	IF(KPX.GE.NPX)GO TO 10
	KPX=KPX+1
	GO TO 520
120	IF(NPX.LE.KPX)GO TO 10
	KK=KPX-1
	R=Q(KPN(KK)+3)+.5
	DO 11 K=KK,NPX
	IF(Q(KPN(K)+3).GT.R)GO TO 12
11	KPX=K
C ABOVE CATCHES THINGS IN SAME POS. AS LAST BAR LINE.
12	IF(KPX.LT.NPX)KPX=KPX+1
10	KQ=KPN(KPX)
	LB=LB-JBAR
	L=KPX-1
C L=TOTAL ITEMS FOR THIS LINE. JBAR=TOTAL BARS, LB=HOW MANY LEFT OVER
	I=L
	IF(LB.NE.0)RETURN
	KPX=1
	KQ=1
	END

	SUBROUTINE STAVES
	COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
	1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2/RSIG/RSIG(0/7)
	COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK(0/7),
	1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) 
	1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
	COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
	1 /STF/RSTFAC(0/7),RSTJ2 /IVV/OSLUR(1)
	COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
	1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
	DIMENSION ENDSTF(450),STFNM(0/7)
C  ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
	EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
 	1,(ENDSTF,KBAR(4))
	1,(R8,RQ(6)),(R9,RQ(7)),(STFNM,KBAR(508))
	DATA SLSP/12.0/
	IF(LC.EQ.1)RA=0
C RA IS LEFT POS OF Q DATA. (IT SHIFTS AS LC CHANGES.)
	KL=1
	KP=1
	LC=LC+1
335	RX=0
	IF(NBAR(LC).EQ.0)JEND=-1
3	JJ=KP

C ******** PUTS IN STAFF ********
	RS=3.
C  RS IS WDCNT FOR SUBR. STAFF
	IF(RT.EQ.0)RS=6
C =6 FOR BOTTOM STAFF.  PUTS IN SPACER.
CC331	IF(IPG)GO TO 411
	HX=8
	G=0
	RX=RT
	DO 611 JP=1,LPG
	RT=RSTNUM(JP)
	LA=RT
	RS=3
C WD CNT IS RS, HX IS CODE(8), ARRAYS AND LPG(JPG) WERE SET UP IN MAIN.
	RR=0
	IF(NAMX.EQ.NAMZ)GO TO 11
	IF(RT.NE.0)GO TO 11
	RS=6
	RR=SPG
C  FOR SPACER ON STAFF 0
11	IF(STFNM(LA).NE.0)RS=7
611	CALL STAFF(RS,HX,G,RHGT(JP),RPSZ(JP),G,G,RR,STFNM(LA),G,G,G)
C  STFNM IS INST. NAME IN P9 OF STAFF PARAMS.
	HX=LPG
	IF(IPG)GO TO 6
	RS=4.
	RT=0
	CALL STAFF(2.,RS,G,HX,G,G,G,G,G,G,G,G)
	DO 1611 JP=1,LPG
	RT=RSTNUM(JP)
	LA=RT
	BR=BRACK(LA)
	IF(BR.EQ.0)GO TO 1611
    	R7=AMOD(BR,100.)
	R4=(BR-R7)/100.
	CALL STAFF(5.,RS,G,R4,G,G,R7,G,G,G,G,G)
1611	CONTINUE
	RT=RX
CC	GO TO 511
CC411	CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP,SP,SP,SP,SP)
CC	HGT=HGT-HX
CI511	IF(JEND)GO TO 60
C FOR PREMATURE PAGE END
CP	IF(K.NE.I)GO TO 6
CI	IF(RT.EQ.0)GO TO 6
CI60	IF(IPG.EQ.0)GO TO 6
CI	RX=RT
CI	RT=0
CI	CALL STAFF(6.,8.,0,0,0,0,1.,SP,SP,SP,SP,SP)
C  PUTS IN SPACER
CI	RT=RX

C  ****** NEXT FOR CLEFS ************
6	RX=1
	IF(CLEF.EQ.-99)GO TO 33
C  ONLY STAFF FOR FIRST LINE AT TOP.
	RX=8.*RSTJ2
C  THE SPACER
CC	LA=0
CC	IF(IPG)GO TO 3011
	LA=LPG
3111	RT=RSTNUM(LA)
	LL=RT
	CLEF=RCLEF(LL)
C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
	LA=LA-1
3011	IF(CLEF.NE.99)CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0,0,0,0,0)
	IF(SIG.EQ.99.OR.Q(2).EQ.17.)GO TO 3211
C  ***** SKIP IF NO KEY SIG. OR KEY SIG. ALREADY APPEARS ON THIS LINE.
	RS=4.
	R5=RSIG(LL)
332	IF(R5.NE.99)CALL STAFF(RS,17.,10.*RSTJ2,0,R5,CLEF,0,0,0,0,0,0)
3211	IF(LA.GT.0)GO TO 3111
	RX=11.*RSTJ2
C  RX SETS POS OF NEXT ITEM ON STAFF
	R7=RX

33	LA=1
	KX=0
61	IF(ENDSTF(LA).EQ.0)GO TO 31
C  JUMP IF NO CARRYOVERS FROM PREVIOUS LINE.
	R5=ENDSTF(LA+1)
	IF(R5.NE.18)GO TO 261
CHECK UP ON METER FROM PREV. LINE.  AVOID DUPLICATE.
	DO 361 KK=1,I
	R=CODEN(KPN,KK,Q,LL)
	IF(R.EQ.4)GO TO 261
C JUMP IF METER FOUND BEFORE 1ST BAR LINE.
361	IF(R.EQ.18)GO TO 161
261	RT=ENDSTF(LA+2)
	IF(R5.NE.18)GO TO 461
	IF(KX)GO TO 461
	KX=-1
	RX=RX+4
	IF(ENDSTF(LA).GT.4)RX=RX+5
461	CALL STAFF(ENDSTF(LA),ENDSTF(LA+1),ENDSTF(LA+3),ENDSTF(LA+4),
	1 ENDSTF(LA+5),ENDSTF(LA+6),ENDSTF(LA+7),ENDSTF(LA+8),
	1 ENDSTF(LA+9),ENDSTF(LA+10),ENDSTF(LA+11),ENDSTF(LA+12))
161	LA=LA+13
	GO TO 61

C  RX SPACES NEXT ITEM TO RIGHT OF LINE BEGINNING.
31	R4=Q(KPN(I)+3)
C GET POS OF LAST ITEM FOR THIS LINE
	DO 32 K=1,I
32	IF(Q(KPN(K)+3).LT.R4)R4=Q(KPN(K)+3)
C ALL THIS NEEDED BECAUSE OF GRACE NOTE AT START OF LINE PROBLEM.

	IF(RA.LT.R4)RA=R4
	R4=RA-.1
C  -.1  FOR ROUND-OFF ERRORS
	LA=I
	DO 831 K=1,I
	KK=KPN(K)+3
C FIND SLURS ETC. BEFORE 1ST NOTES OR REST. (NOT NEG.)
	IF(Q(KK).GE.RA)GO TO 231
831	Q(KK)=0
231	RA=CODEN(KPN,LA,Q,K4)
	IF(RA.EQ.4)GO TO 131
	IF(RA.NE.44)GO TO 931
	IF(Q(K4).LE.2)GO TO 131
CATCHES BAR LINES ON UPPER STAVES.
931	LA=LA-1
	GO TO 231
131	RA=Q(K4+3)
	R5=RA+.001
C +.001 IS TO CATCH SLIGHT ROUNDOFF ERRORS WHEN CODE 44 IS LAST ITEM.
	DO 731 K=1,I
CC	KK=KPN(K)  	R=Q(KK+1)
	R=CODEN(KPN,K,Q,KK)
	IF(R.EQ.44)GO TO 631
	IF(R.EQ.7)GO TO 631
	IF(R.NE.5)GO TO 731
631	IF(Q(KK).LT.4)GO TO 731
	R=Q(KK+6)
	IF(R.LT.R5)GO TO 731
C R5 = LEFT SIDE OF ITEM NOW, R= RIGHT SIDE.
	Q(KK+6)=R5
C  CATCHES RIGHT SIDE OF THINGS FOR MOVER. (PEDS?)
731	CONTINUE
	RS=-1
C  -1 SO ALL STAVES WILL MOVE AT ONCE.
CC	RS=0
	R7=0
C R7=0 FOR GETPTS TO LOOK AT ALL STAVES.
	R8=RX
	R9=200.
	LL=0
	L=I
	CALL PTMOVE(Q,KPN)
	IF(LA.EQ.I)RETURN
C NEXT PUTS METER JUST BEYOND END OF LINE
	R=202
	R7=Q(KPN(LA+1)+3)
C  R7 HOLDS STAFF NUM. FOR THINGS BEYOND END OF LINE.
	DO 531 K5=LA+1,I
	K7=KPN(K5)
	K4=0
	IF(Q(K7+1).EQ.18)K4=Q(K7+5)*100+Q(K7+6)
C  K4 STORES METER (TOP*100+BOTTOM)
	IF(Q(K7+3).EQ.R7)GO TO 531
	R7=Q(K7+3)
C THIS PROBABLY WON'T ALWAYS DO THE RIGHT THING!!
	R=R+5
CM	IF(MTR1.GT.0.AND.K4.NE.0)MTR2=K4
531	Q(K7+3)=R
CM431	Q(K7+3)=R
CM531	IF(K4.NE.0.AND.MTR1)MTR1=K4
	END